# digest.tcl - Copyright (C) 2002 Pat Thoyts <pathoyts@users.sourceforge.net>
#
# Implement HTTP Digest Authentication
#
#
# The page handler needs to process headers. If we receive a
# 401 Unauthorised or the proxy equivalent we may get:
# WWW-Authenticate: Digest
#       realm="testrealm@host.com",
#       qop="auth,auth-int",
#       nonce="dcd98b7102dd2f0e8b11d0f600bfb0c093",
#       opaque="5ccc069c403ebaf9f0171e9517f40e41"
#
# qop auth as below, auth-int includes a md5 sum of the page data too.
# No qop means a different final response calculation (without nonce values).
#
# After a successful transaction you get an Authentication-Info header.
# The nextnonce value should be used to calculation the next Authentication
# header
# You may get a rspauth which can be used by the client to validate the
# server's response.

package require http 2.0;               # tcl core
package require md5;                    # tcllib

namespace eval digest {

    variable version 1.0
    
    variable noncecount
    if {![info exists noncecount]} {
	array set noncecount {}
    }
}


proc digest::Header {args} {
    foreach {elt val} [eval Response $args] {
	lappend r "$elt=\"$val\""
    }
    return [concat Digest [join $r ", "]]
}

proc digest::Parse {token} {
    upvar $token state
    set r {}

    if {$state(querylength) < 1} {
	lappend r -cmd GET
    } else {
	lappend r -cmd POST
    }
    lappend r -uri $state(url)

    set ndx [lsearch -exact $state(meta) "WWW-Authenticate"]
    if {$ndx < 0} {
	return -code error "no WWW-Authenticate header found"
    }
    incr ndx
    set auth [lindex $state(meta) $ndx]
    if {![string match Digest* $auth]} {
	return -code error "this is not Digest auth: $state(meta)"
    }
    foreach pair [split [string range $auth 7 end] ","] {
	regexp {([^=]+)=(.*)} [string trim $pair] -> name value
	lappend r -$name [string trim $value "\""]
    }
    return $r
}

proc digest::GetUserInfo {{user {}} {passwd {}}} {

    namespace eval ::tmp {
	
	source credentials
    }
    set ret [list $::tmp::username $::tmp::password]
    namespace delete ::tmp
    return $ret
}

proc digest::Response {args} {
    variable noncecount

    array set opts [list user {} passwd {} qop {} \
			getinfo [namespace origin GetUserInfo]]
    foreach {opt value} $args {
	switch -glob -- $opt {
	    -get*  {
		if {[info command $value] == {}} {
		    return -code error "invalid argument:\
                            \"$value\" is not a command"
		}
		set opts(getinfo) $value
	    }
	    -us*   { set opts(user) $value }
	    -p*    { set opts(passwd) $value }
	    -nonce { set opts(nonce) $value }
	    -qop   { set opts(qop) $value }
	    -realm { set opts(realm) $value }
	    -cmd   { set opts(cmd) $value }
	    -uri   { set opts(uri) $value }
	    -op*   { set opts(opaque) $value }
	    -cnon* { set opts(cnonce) $value }
	    -algo* { set opts(alogrithm) $value }
	    -domain { set opts(domain) $value}
	    default {
		return -code error "invalid option \"$opt\": must be one of\
                      -username, -password, -getinfo, -nonce, -qop, -realm,\
                      -cmd, -uri, -operation, -algorithm, -domain or -cnonce"
	    }
	}
    }

    # Check we have everything we need.
    foreach elt [list nonce realm cmd uri] {
	if {![info exists opts($elt)]} {
	    return -code error "invalid arguments: \"$elt\" must be supplied"
	}
    }

    # For testing - permit the client nonce value to be specified.
    if {![info exists opts(cnonce)]} {
	set opts(cnonce) [format %08x [clock clicks]]
    }

    # Only MD5 is acceptable as a calculation algorithm (sec: 3.2.1)
    if {[info exists opts(algorithm)]} {
	if {![string match "MD5*" $opts(algorithm)]} {
	    return -code error "invalid algorithm spceified:\
                 \"$opts(algorithm)\" is not supported."
	}
    }

    # Calculate the nonce count value: - check server as well as realm?
    if {![info exists noncecount($opts(nonce))]} {
	set noncecount($opts(nonce)) 0
    }
    set nc [incr noncecount($opts(nonce))]

    # Prompt for password and user interactively if not supplied.
    if {$opts(user) == {} || $opts(passwd) == {}} {
	set r [$opts(getinfo) $opts(user) $opts(passwd)]
	foreach {opts(user) opts(passwd)} $r {}
    }

    # Build the response
    set A1 [md5::md5 "$opts(user):$opts(realm):$opts(passwd)"]
    set A2 [md5::md5 "$opts(cmd):$opts(uri)"]
    set nc [format %08u $nc]

    switch -exact -- $opts(qop) {
	{} {
	    set response [md5::md5 "$A1:$opts(nonce):$A2"]
	}
	auth {
	    set response [md5::md5 "$A1:$opts(nonce):$nc:$opts(cnonce):$opts(qop):$A2"]
	}
	default {
	    return -code error ""
	}
    }

    set result [list \
		    username  $opts(user) \
		    realm     $opts(realm) \
		    nonce     $opts(nonce) \
		    uri       $opts(uri) \
		    qop       $opts(qop) \
		    nc        $nc \
		    cnonce    $opts(cnonce) \
		    response  $response]
    if {[info exists opts(opaque)]} {
	lappend result opaque $opts(opaque)
    }

    return $result
}

# -------------------------------------------------------------------------

package provide digest $::digest::version

# -------------------------------------------------------------------------

